      SUBROUTINE PROTRE
C! Produce the FLOW diagram
      INCLUDE 'params.h'
      INCLUDE 'tables.h'
      INCLUDE 'lunits.h'
      INCLUDE 'trecom.h'
      INCLUDE 'ignore.h'
C
      CHARACTER*(MXCHR) CLINE,CTITL(MTITL),CLINO
      CHARACTER*(MXNAM) CNAM,CNAM2,CNAME(MLEV,MNLEV)
      CHARACTER*(LCDOIF) CDF,CDOIF(MLEV,MNLEV)
      CHARACTER*1 CHAR
      CHARACTER*(MXLIN) CFORM
      INTEGER NDONE(MLEV),NMAX(MLEV),SEARCH
      EXTERNAL SEARCH
      LOGICAL OK
C
C statement function iposl
      IPOSL(IL) = (MXOFF+NDIS)*(IL-1) + 1
C
      WRITE(LOUT,'(A)') ' '
      WRITE(LOUT,'(A)') ' PROTRE Begins ....'
      WRITE(LOUT,'(A)') ' '
C
      DO 5 IC=1,MXCHR
        CLINO(IC:IC) = ' '
   5  CONTINUE
C
C check for first procedure unknown
C
      IF(CTREE.EQ.'$$$$') CTREE = PROCED_NAME(1)
      NSUBNM = 1
      CSUBNM(1) = CTREE
      CDF       = ' '
C
      IOFF = NDIS+MXOFF/2-2
C
      WRITE(LOUTRE,550)
  550 FORMAT(1X,20('*'),'              ProTre             ',20('*'),
     &     /,1X,20(' '),'              ======             ',20(' '),
     &   ///,1X,20(' '),' Meaning of Symbols:                     ',
     &     /,1X,20(' '),' -------------------                     ',
     &    //,1X,20(' '),' .   ==> terminal node in the tree       ',
     &     /,1X,20(' '),' *   ==> external procedure              ',
     &     /,1X,20(' '),' >   ==> subtree node, expanded below    ',
     &     /,1X,20(' '),' +   ==> multiply called terminal node   ',
     &     /,1X,20(' '),' ]   ==> procedure calling only externals',
     &     /,1X,20('-'),'---------------------------------',20('-'),
     &     /,1X,20(' '),' ?   ==> module is in IF clause',
     &     /,1X,20(' '),' (   ==> module is in DO loop',
     &    //,1X,20('*'),'*********************************',20('*'))
C
      IF(.NOT.LEXT) WRITE(LOUTRE,551)
  551 FORMAT(//,1X,'EXTERNAL procedure names will not appear ',/)
      IF(NIGNO.NE.0) THEN
         WRITE(LOUTRE,'(A)')
     &   ' --------------------------------------------------'
         WRITE(LOUTRE,'(1X,I5,A)') NIGNO,' Module(s) will be ignored :'
         WRITE(LOUTRE,'(1X,6A8)') (CIGNO(IG),IG=1,NIGNO)
         WRITE(LOUTRE,'(A,/)')
     &   ' --------------------------------------------------'
      ENDIF
C
  300 CONTINUE
      IF(NSUBNM.LE.0) GOTO 40
      CNAM = CSUBNM(1)
C
C IGNORE SPECIFIED MODULES
C
      DO 301 IG=1,NIGNO
         IF(CNAM.EQ.CIGNO(IG)) GOTO 30
  301 CONTINUE
C
      WRITE(LOUTRE,500) CNAM
  500 FORMAT(/,1X,'=============',
     &       /,1X,'Node name ==> ',A,
     &       /,1X,'=============',/)
C
      DO 10 J=1,MLEV
         NDONE(J) = 0
         NMAX(J)  = 0
         DO 10 I=1,MNLEV
            CNAME(J,I) = ' '
   10 CONTINUE
C
      ILEV = 1
      INAM = 1
      CNAME(ILEV,INAM) = CNAM
      CLINE = CLINO
C
C pseudo-recursive tree search
C
   20 CONTINUE
C
      IPNAM = SEARCH(CNAM)
      IF(IPNAM.EQ.0) GOTO 910
C
C compose leading line
C
      CLINE(:MXCHR) = CLINO(:MXCHR)
      LENID = LENOCC(CDF)
      DO 55 IL=ILEV,2,-1
        IBEG = IPOSL(IL) - IOFF
        IF(IL.EQ.ILEV) THEN
          CLINE(IBEG:IBEG) = '|'
          DO 56 IP=IBEG+1,IBEG+IOFF
            IPL=IP-IBEG
            IF(IPL.GT.LENID) CHAR = '-'
            IF(IPL.LE.LENID) THEN
              CHAR = CDF(IPL:IPL)
              IF(IP.EQ.IBEG+IOFF) CHAR = '+'
            ENDIF
            CLINE(IP:IP) = CHAR
   56     CONTINUE
          GOTO 55
        ENDIF
        IF(NDONE(IL-1).GE.NMAX(IL-1)) GOTO 55
        CLINE(IBEG:IBEG) = '|'
   55 CONTINUE
C
      IF(PROCED_NCALLS(IPNAM).EQ.0) THEN
C stub
         CHAR = '.'
         IF(PROCED_NCALLEDBY(IPNAM).GE.1) CHAR = '+'
         IF(PROCED_EXTERN(IPNAM)) CHAR = '*'
         CFORM = CLINE(:IPOSL(ILEV))//CNAM//' '//CHAR
         LCOM = LENOCC(PROCED_DESCRIP(IPNAM))
         LFOR = LENOCC(CFORM)
         IF(LFOR.LT.LPSTA) THEN
           CFORM(LFOR+1:LPSTA) = ' '
           CFORM(LPSTA:LPSTA+1) = ': '
           IF(LCOM.NE.0) THEN
             CFORM(LPSTA+2:MXLIN) = PROCED_DESCRIP(IPNAM)(:LCOM)
           ELSE
             CFORM(LPSTA+2:MXLIN) = ' '
           ENDIF
         ENDIF
         WRITE(LOUTRE,'(1X,A)') CFORM
         GOTO 45
      ELSE IF(PROCED_NCALLS(IPNAM).GT.0) THEN
C multiple call (general case)
        IOK = 0
        DO 73 IC=1,PROCED_NCALLS(IPNAM)
           IF(.NOT.PROCED_EXTERN(PROCED_CALLS(IPNAM,IC))) IOK = 1
   73   CONTINUE
        IF(NDONE(ILEV).EQ.0) THEN
          CHAR = ' '
          IF(PROCED_NCALLEDBY(IPNAM).GT.1) THEN
C
C sub tree ... check if this pass is for expansion
C
            IFOUN = 0
            IF(ILEV.EQ.1) THEN
              CHAR = ' '
              DO 66 IS=1,NSUBNM
                IF(CNAM.EQ.CSUBNM(IS)) THEN
                  LSUBNM(IS) = .TRUE.
                  IFOUN = IS
                ENDIF
   66         CONTINUE
            ELSE
              CHAR = '>'
            ENDIF
          ENDIF
          IF(IOK.EQ.0) CHAR = ']'
          CFORM = CLINE(:IPOSL(ILEV))//CNAM//' '//CHAR
          LCOM = LENOCC(PROCED_DESCRIP(IPNAM))
          LFOR = LENOCC(CFORM)
          IF(LFOR.LT.LPSTA) THEN
             CFORM(LFOR+1:LPSTA) = ' '
             CFORM(LPSTA:LPSTA+1) = ': '
             IF(LCOM.GT.0) THEN
                CFORM(LPSTA+2:MXLIN) = PROCED_DESCRIP(IPNAM)(:LCOM)
             ELSE
                CFORM(LPSTA+2:MXLIN) = ' '
             ENDIF
          ENDIF
          WRITE(LOUTRE,'(1X,A)') CFORM
          IF(PROCED_NCALLEDBY(IPNAM).GT.1.AND.IFOUN.EQ.0) THEN
C
C sub tree which will be expanded later. add to name list
C (but only if not already there).
C
            DO 67 IS=1,NSUBNM
               IF(CNAM.EQ.CSUBNM(IS)) GOTO 45
   67       CONTINUE
            IF(NSUBNM.GE.MSUBT) THEN
               WRITE(LOUT,'(A,I6,A)') ' Max of ',MSUBT,
     &                    ' sub-trees exceeded'
               GOTO 45
            ENDIF
C
C IGNORE EXTERNALS, IF THAT IS REQUIRED
C
            IF(.NOT.LEXT.AND.IOK.EQ.0) GOTO 45
            NSUBNM = NSUBNM + 1
            CSUBNM(NSUBNM) = CNAM
            LSUBNM(NSUBNM) = .FALSE.
            GOTO 45
          ENDIF
        ENDIF
C
C fill all names at this level
C
        IF(NDONE(ILEV).EQ.0) THEN
          NC = 0
          DO 36 IN=1,PROCED_NCALLS(IPNAM)
             IPNAM2 = PROCED_CALLS(IPNAM,IN)
C
C IGNORE EXTERNALS IF REQUIRED
C
             IF(.NOT.LEXT.AND.PROCED_EXTERN(IPNAM2)) GOTO 36
             NC = NC + 1
             CNAME(ILEV,NC) = PROCED_NAME(IPNAM2)
             CDOIF(ILEV,NC)(:LCDOIF) = PROCED_DOIF(IPNAM,IN)(:LCDOIF)
   36     CONTINUE
          NMAX(ILEV) = NC 
        ENDIF
        GOTO 46
      ENDIF
   45 CONTINUE
C
C end of level. move up one
C
      ILEV = ILEV - 1
      IF(ILEV.EQ.0) GOTO 30
   46 CONTINUE
      IF(NDONE(ILEV).GE.NMAX(ILEV)) THEN
        NDONE(ILEV) = 0
        GOTO 45
      ENDIF
      CNAM = CNAME(ILEV,NDONE(ILEV)+1)
      CDF(:LCDOIF)  = CDOIF(ILEV,NDONE(ILEV)+1)(:LCDOIF)
      NDONE(ILEV) = NDONE(ILEV) + 1
      ILEV = ILEV + 1
      GOTO 20
   30 CONTINUE
C
C end of this tree. shift names in sub-tre list and start again
C
        DO 72 I=1,NSUBNM-1
          LSUBNM(I) = LSUBNM(I+1)
          CSUBNM(I) = CSUBNM(I+1)
  72    CONTINUE
        NSUBNM = NSUBNM - 1
      IPOIN = 0
   35 IPOIN = IPOIN + 1
      IF(IPOIN.GT.NSUBNM) GOTO 300
      IF(LSUBNM(IPOIN)) THEN
        DO 71 I=IPOIN,NSUBNM-1
          LSUBNM(I) = LSUBNM(I+1)
          CSUBNM(I) = CSUBNM(I+1)
  71    CONTINUE
        NSUBNM = NSUBNM - 1
        IPOIN = IPOIN - 1
      ENDIF
      GOTO 35
C
   40 CONTINUE
C
C finished all trees. home to beddy-bies
C
      WRITE(LOUT,'(A)') ' PROTRE Finished'
      IERROR = 0
      GOTO 999
  910 WRITE(LOUTRE,911) CNAM
      WRITE(LOUT,911) CNAM
  911 FORMAT(1X,'PROTRE --> ROUTINE:',A,' NOT FOUND IN PROCEDURE TABLE')
      IERROR = 2
  999 CONTINUE
      END
